perm filename PPROC2.SAI[PNT,HE]9 blob
sn#520659 filedate 1980-07-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00006 00003 ! oldsav
C00007 00004 ! mk_clause,viaclause
C00010 00005 ! mk_cond, force routines
C00018 00006 ! withclause
C00023 00007 ! onclause
C00029 00008 ! movepcode
C00038 00009 ! moveproc
C00043 00010 ! centerpcode
C00046 00011 ! centerproc
C00048 00012 ! handpcode
C00055 00013 ! handproc,openproc
C00058 00014 ! toproc,byproc
C00060 00015 ! stoppcode
C00061 00016 ! stopproc
C00062 00017 ! operproc
C00068 00018 ! driveproc
C00070 00019 ! onproc
C00072 00020 END "PPROC2"
C00073 ENDMK
C⊗;
ENTRY;
BEGIN "PPROC2"
DEFINE $$PRGID=TRUE;
DEFINE $PPROC2=TRUE;
DEFINE $ALTER_EGO=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
RECORD_CLASS CLAUSE(RPTR(EXPR$)DECL,HEADER,BODY,TAIL,KILDECL,FFRAME;
REAL FVALUE;INTEGER CLAUSE_CLASS,TYPE,CMONCODE,GBITS;
RPTR(CLAUSE)DURATION,VELOCITY,EVENT);
! last two valid only for VIA clauses ;
REdefine
indices(name, postfix)"[][]"=[
redefine xxcount=1;
redefine xx(xxarg)=[
redefine xxtemp= [ define xxarg]&[postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name ];
DEFINE MOVE_ST=1,
CENTER_ST=2,
OPERATE_ST=4,
ON_ST='10,
OPEN_ST='20;
DEFINE CONDITION_INFO=[
XX(NEITHER, 0)
XX(EQUALITY, 0)
XX(RELATIONAL, 0)
XX(FORCE, MOVE_ST+ON_ST)
XX(TORQUE, MOVE_ST+ON_ST+OPERATE_ST)
XX(DURATION, MOVE_ST+ON_ST+OPERATE_ST)
XX(APPROACH, MOVE_ST)
XX(DEPARTURE, MOVE_ST)
XX(SPEED_FACTOR,MOVE_ST+OPEN_ST)
XX(FORCE_FRAME, MOVE_ST)
XX(NULLING, MOVE_ST+OPEN_ST)
XX(STIFFNESS, MOVE_ST)
XX(DRIVER_TURNS,OPERATE_ST)
XX(RTMOVE, MOVE_ST)
XX(WOBBLE, MOVE_ST)
XX(STOP_WAIT_TIME, 0)
XX(ANGULAR_VELOCITY, OPERATE_ST)
XX(FAILURE, MOVE_ST+CENTER_ST+OPERATE_ST+OPEN_ST)
XX(EXPRESSION, MOVE_ST+ON_ST+OPERATE_ST+CENTER_ST+OPEN_ST)
XX(EVENT, MOVE_ST+ON_ST+OPERATE_ST+CENTER_ST+OPEN_ST)
XX(SETBASE, MOVE_ST)
XX(DRIVER_TORQUE, OPERATE_ST)
XX(CLOCKWISE, OPERATE_ST)
XX(CCLOCKWISE, OPERATE_ST)
XX(VELOCITY, MOVE_ST)
XX(POS, MOVE_ST)];
INDICES(CONDITION_INFO,_COND);
define cond_count=xxcount;
REDEFINE XX(a,b)=[b,];
preload_array(VALID, CONDITION_INFO, INTEGER, 1,cond_count);
RPTR(EXPR$) PROCEDURE $RAPPEND(RPTR(RSTACK)R);
BEGIN
IF RSIZE(R)=0 THEN RETURN(NULL_RECORD);
RTRIM(R);
RETURN($AAPPEND(RSTACK:STACK[R]));
END;
DEFINE ON_CLASS=1,
WITH_CLASS=2,
VIA_CLASS=3;
DEFINE NONULLING_GBITS=1,
WOBBLE_GBITS=2,
SPEEDF_GBITS=4,
DURREL_GBITS='60; ! Duration relation present, which indicated by ;
DEFINE DURLB_GBITS='20; ! lower bound on duration ;
DEFINE DURUB_GBITS='40; ! upper bound on duration ;
DEFINE DUREB_GBITS='60; ! exact bound ;
DEFINE VELOC_GBITS='100,
TCODE_GBITS='200,
VIAPT_GBITS='400,
DEPRPT_GBITS='1000,
APPRPT_GBITS='2000,
NODEPR_GBITS='4000; ! No departure point ;
DEFINE DESTPT_GBITS='10000;
! oldsav ;
RPTR(EXPR$) OLDCFRAME; ! control frame being moved ;
PROCEDURE OLDSAV(STRING CMD,OBJ; RPTR(EXPR$)CFRAME);
BEGIN
OLDCMD←CMD;
OLDOBJ←OBJ;
OLDCFRAME←CFRAME;
END;
PROCEDURE GETOLD(REFERENCE STRING CMD,OBJ; REFERENCE RPTR(EXPR$)CFRAME);
BEGIN
CMD←OLDCMD;
OBJ←OLDOBJ;
CFRAME←OLDCFRAME;
END;
! mk_clause,viaclause;
RPTR(CLAUSE)PROCEDURE MK_CLAUSE(INTEGER TYPE,GBITS(0);RPTR(EXPR$)BODY(NULL_RECORD));
BEGIN RPTR(CLAUSE)CL;
CL←NEW_RECORD(CLAUSE);
CLAUSE:TYPE[CL]←TYPE;
CLAUSE:GBITS[CL]←GBITS;
CLAUSE:BODY[CL]←BODY;
RETURN(CL);
END;
RECURSIVE RPTR(CLAUSE) PROCEDURE VIACLAUSE;
BEGIN ! only positions so far;
RPTR(CLAUSE)CL;
CL←MK_CLAUSE(POS_COND,VIAPT_GBITS,$$GTANYEXP("VIA CLAUSE",#FR));
CLAUSE:CLAUSE_CLASS[CL]←VIA_CLASS;
GTOKEN(FALSE);
WHILE EQU(TOKEN,"WHERE") OR EQU(TOKEN,"THEN") DO
IF EQU(TOKEN,"WHERE") THEN
BEGIN "where"
GTOKEN;
IF EQU(TOKEN,"DURATION") THEN
BEGIN INTEGER BITS;
GTOKEN;
IF TOKEN="=" THEN BITS←DUREB_GBITS
ELSE IF TOKEN=">" THEN BITS←DURLB_GBITS
ELSE IF TOKEN="<" THEN BITS←DURUB_GBITS
ELSE ERROR("Need =,> or < here");
CLAUSE:DURATION[CL]←
MK_CLAUSE(DURATION_COND,BITS,$$GTANYEXP("DURATION",#SC));
CLAUSE:GBITS[CL]←CLAUSE:GBITS[CL] LOR BITS;
END
ELSE IF EQU(TOKEN,"VELOCITY") THEN
BEGIN
WORD_READ("=");
CLAUSE:VELOCITY[CL]←
MK_CLAUSE(VELOCITY_COND,VELOC_GBITS,$$GTANYEXP("VELOCITY",#VT));
CLAUSE:GBITS[CL]←CLAUSE:GBITS[CL] LOR VELOC_GBITS;
END
ELSE ERROR("Unrecognized clause: "&token);
GTOKEN(FALSE);
END "where"
ELSE BEGIN "then"
END "then";
STOKEN←TRUE;
RETURN(CL);
END;
! mk_cond, force routines;
RECURSIVE RPTR(CLAUSE)PROCEDURE MK_COND(RPTR(EXPR$)BODY; INTEGER TYPE);
BEGIN
RPTR(CLAUSE)CL;
CL←NEW_RECORD(CLAUSE);
CLAUSE:TYPE[CL]←TYPE;
CLAUSE:DECL[CL]←BODY;
RETURN(CL);
END;
RECURSIVE RPTR(EXPR$) PROCEDURE ACTION$;
BEGIN ! checks for DO and then a statement ;
INTEGER TMPOFF; RPTR(EXPR$)E;
TMPOFF←$TMPOFF; $TMPOFF←UPLEVEL($TMPOFF);
E←RPARSE("DO");
$TMPOFF←TMPOFF;
RETURN(E);
END;
RPTR(EXPR$)PROCEDURE $FFPCODE(RPTR(EXPR$)CFRAME; INTEGER BITS;
RPTR(EXPR$)E(NULL_RECORD));
BEGIN
RPTR(EXPR$)ARRAY F[1:3];
RPTR(SYMBOL)C;
IF E=NULL_RECORD THEN
F[1]←EXPR$3(XAGTVAL,SYMBOL:INDEX[C←CHECK("NILTRANS",#TR)],
SYMBOL:OFFSET[C])
ELSE F[1]←E;
F[2]←CFRAME;
F[3]←EXPR$2(XPTFRCST,BITS LAND '400); ! get whether station or hand ;
RETURN($AAPPEND(F));
END;
PROCEDURE VBITS(STRING ERR; REFERENCE INTEGER BITS);
BEGIN "vector directional bits"
GTOKEN;
IF EQU(TOKEN,"XHAT") THEN RETURN
ELSE IF EQU(TOKEN,"YHAT") THEN BITS←BITS LOR '1000
ELSE IF EQU(TOKEN,"ZHAT") THEN BITS←BITS LOR '2000
ELSE ERROR(ERR&" Need XHAT or YHAT or ZHAT here.");
END;
PROCEDURE RBITS(STRING ERR; REFERENCE INTEGER BITS);
BEGIN "relational bits"
GTOKEN;
IF TOKEN="≥" OR TOKEN =">" THEN BITS←BITS LOR '100000
ELSE IF TOKEN="≤" OR TOKEN="<" THEN BITS←BITS
ELSE ERROR(ERR&" need > or ≤ here");
END;
RECURSIVE RPTR(CLAUSE)PROCEDURE FORCECMON(RPTR(EXPR$)CFRAME; INTEGER COND;
BOOLEAN ABSOLUTE(FALSE),ISCLAUSE(TRUE);INTEGER OFFSET(0));
BEGIN
BOOLEAN GE; RPTR(EXPR$)EXP,ACTION,FR,CMBODY;
RPTR(CLAUSE)CL; RPTR(SYMBOL)C;
INTEGER I,IPC,BITS,V;
IF COND=TORQUE_COND THEN BITS←'3000 ELSE BITS←0; GTOKEN;
IF TOKEN="(" THEN
BEGIN
VBITS("FORCECM: ",BITS); WORD_READ(")");
IF ABSOLUTE THEN BEGIN WORD_READ("|"); BITS←BITS + '20000; END;
RBITS("FORCE CM: ",BITS);
EXP←$$GTANYEXP("FORCECM",#SC);
END
ELSE BEGIN
STOKEN←TRUE;
IF ABSOLUTE THEN BEGIN WORD_READ("|"); BITS←BITS LOR '20000; END;
RBITS("FORCE CM: ",BITS);
EXP←$$GTANYEXP("FORCECM",#SC);
WORD2_READ("ALONG","ABOUT","FORCECM: ");
VBITS("FORCECM: ",BITS)
END;
GTOKEN; FR←NULL_RECORD;
IF EQU(TOKEN,"OF") THEN
BEGIN
FR←$$GTANYEXP("FORCECM",#TR); GTOKEN;
IF EQU(TOKEN,"IN") THEN
BEGIN GTOKEN;
IF EQU(TOKEN,"HAND") THEN BITS←BITS
ELSE IF EQU(TOKEN,"STATION") THEN BITS←BITS+'400
ELSE ERROR("FORCECM: can only specify in HAND or STATION");
END ELSE BEGIN STOKEN←TRUE; BITS←BITS+'400; END;
WORD_READ("DO");
END
ELSE BEGIN IF NOT EQU(TOKEN,"DO") THEN ERROR("FORCECM: Need DO here");
BITS←BITS+'400; ! default is station;
END;
STOKEN←TRUE;
ACTION←ACTION$;
CMBODY←$FRCPCODE(EXP,ACTION,CFRAME);
IF ISCLAUSE THEN CL←MK_COND($CMONPCODE(CMBODY,#CMFRC,BITS),COND)
ELSE CL←MK_COND($ONPCODE(CMBODY,OFFSET,#CMFRC,BITS),COND);
CLAUSE:CMONCODE[CL]←#CMFRC;
CLAUSE:FVALUE[CL]←BITS;
CLAUSE:TYPE[CL]←COND;
IF FR THEN CLAUSE:FFRAME[CL]←$FFPCODE(CFRAME,BITS,FR);
RETURN(CL);
END;
RPTR(EXPR$) PROCEDURE $FRCCLPCODE(RPTR(EXPR$)CFRAME,EXP;INTEGER BITS);
BEGIN
RPTR(EXPR$)ARRAY F[1:3];
F[1]←EXP;
F[2]←CFRAME;
F[3]←EXPR$2(XPCOMPLY,BITS LAND '777377);
RETURN($AAPPEND(F));
END;
RPTR(CLAUSE)PROCEDURE FORCECL(INTEGER BITS0,COND; RPTR(EXPR$)CFRAME);
BEGIN RPTR(CLAUSE)CL;
RPTR(EXPR$)EXP,FR;
INTEGER I,V,IPC,TMPOFF,BITS;
RPTR(SYMBOL)C;
GTOKEN;
BITS←BITS0;
IF TOKEN="(" THEN
BEGIN
VBITS("FORCE CLAUSE: ",BITS);
WWORD_READ(")","=");
EXP←$$GTANYEXP("FORCE COMPLIANCE",#SC);
END
ELSE IF TOKEN = "=" THEN
BEGIN
EXP←$$GTANYEXP("FORCE COMPLIANCE",#SC);
GTOKEN;
IF EQU(TOKEN,"ALONG") OR EQU(TOKEN,"ABOUT") THEN
VBITS("FORCE CLAUSE: ",BITS)
ELSE ERROR("Need ALONG or ABOUT here");
END
ELSE ERROR("Need ( here ");
GTOKEN(FALSE);
FR←NULL_RECORD;
IF EQU(TOKEN,"OF") THEN
BEGIN
FR←$$GTANYEXP("FORCE CLAUSE",#TR);
GTOKEN(FALSE);
IF EQU(TOKEN,"IN") THEN
BEGIN GTOKEN;
IF EQU(TOKEN,"HAND") THEN BITS←BITS
ELSE IF EQU(TOKEN,"FIXED") THEN BITS←BITS+'400
ELSE ERROR("FORCECM: can only specify in HAND or STATION");
END ELSE BEGIN STOKEN←TRUE; BITS←BITS+'400; END;
END
ELSE BEGIN
STOKEN←TRUE;
BITS←BITS+'400; ! default is station;
END;
CL←NEW_RECORD(CLAUSE);
CLAUSE:BODY[CL]←$FRCCLPCODE(CFRAME,EXP,BITS);
CLAUSE:FVALUE[CL]←BITS;
CLAUSE:TYPE[CL]←COND;
IF FR THEN CLAUSE:FFRAME[CL]←$FFPCODE(CFRAME,BITS,FR);
RETURN(CL);
END;
! withclause;
RECURSIVE RPTR(CLAUSE) PROCEDURE WITHCLAUSE(INTEGER STATEMENT_TYPE;
RPTR(EXPR$)CFRAME);
BEGIN RPTR(CLAUSE)CL;
GTOKEN;
IF EQU(TOKEN,"FORCE_WRIST") THEN
BEGIN BOOLEAN NOBASE; RPTR(EXPR$)E; NOBASE←FALSE;
GTOKEN;
IF EQU(TOKEN,"NOT") THEN BEGIN NOBASE←TRUE; GTOKEN; END;
IF NOT EQU(TOKEN,"ZEROED")
THEN ERROR("FORCE_WRIST CLAUSE:: must be ZEROED or NOT ZEROED");
IF ¬NOBASE THEN E←$PCD1(XXSETBAS);
CL←MK_CLAUSE(SETBASE_COND,0,E);
END
ELSE IF EQU(TOKEN,"FORCE") THEN CL←FORCECL(0,FORCE_COND,CFRAME)
ELSE IF EQU(TOKEN,"TORQUE") AND STATEMENT_TYPE=OPERATE_ST THEN
BEGIN
WORD_READ("=");
CL←MK_CLAUSE(DRIVER_TORQUE_COND,0,$$GTANYEXP("DRIVER_TORQUE",#SC));
END
ELSE IF EQU(TOKEN,"TORQUE") THEN CL←FORCECL('3000,TORQUE_COND,CFRAME)
ELSE IF EQU(TOKEN,"STIFFNESS") THEN
BEGIN
WORD_READ("=");
SETSTIFFPROC;
CL←MK_CLAUSE(STIFFNESS_COND,0,$$PCODE);
END
ELSE IF EQU(TOKEN,"WOBBLE") THEN
BEGIN
WORD_READ("=");
CL←MK_CLAUSE(WOBBLE_COND,WOBBLE_GBITS,$$GTANYEXP("WOBBLE command",#SC));
END
ELSE IF EQU(TOKEN,"DURATION") THEN
BEGIN
INTEGER BITS;
GTOKEN;
IF TOKEN="=" THEN BITS←DUREB_GBITS
ELSE IF TOKEN=">" THEN BITS←DURLB_GBITS
ELSE IF TOKEN="<" THEN BITS←DURUB_GBITS
ELSE ERROR("Need =,> or < here");
CL←MK_CLAUSE(DURATION_COND,BITS,$$GTANYEXP("DURATION",#SC));
END
ELSE IF EQU(TOKEN,"ANGULAR_VELOCITY") THEN
BEGIN
WORD_READ("=");
CL←MK_CLAUSE(ANGULAR_VELOCITY_COND,0,$$GTANYEXP("ANGULAR_VELOCITY",#SC));
END
ELSE IF EQU(TOKEN,"SPEED_FACTOR") THEN
BEGIN
WORD_READ("=");
CL←MK_CLAUSE(SPEED_FACTOR_COND,SPEEDF_GBITS,$$GTANYEXP("SPEED_FACTOR",#SC));
END
ELSE IF EQU(TOKEN,"NULLING") THEN CL←MK_CLAUSE(NULLING_COND)
ELSE IF EQU(TOKEN,"NO_NULLING") THEN
CL←MK_CLAUSE(NULLING_COND,NONULLING_GBITS)
ELSE IF EQU(TOKEN,"APPROACH") THEN
BEGIN
RPTR(EXPR$)E;
WORD_READ("=");
CL←MK_CLAUSE(APPROACH_COND,APPRPT_GBITS);
GTOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN CLAUSE:GBITS[CL]←0 ELSE
BEGIN
STOKEN←TRUE;
E←$$GTEXPR;
IF #SC≤EXPR$:TYPE[E]≤#FR
THEN CLAUSE:BODY[CL]←E
ELSE ERROR("Need scalar,vector or trans value for APPROACH");
END;
END
ELSE IF EQU(TOKEN,"DEPARTURE") THEN
BEGIN
RPTR(EXPR$)E;
WORD_READ("=");
CL←MK_CLAUSE(DEPARTURE_COND,DEPRPT_GBITS);
GTOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN CLAUSE:GBITS[CL]←NODEPR_GBITS
ELSE
BEGIN STOKEN←TRUE;
E←$$GTEXPR;
IF #SC≤EXPR$:TYPE[E]≤#FR
THEN CLAUSE:BODY[CL]←E
ELSE ERROR("Need scalar,vector or trans value for DEPARTURE");
END;
END
ELSE ERROR("Can't handle "&token& " clause now");
CLAUSE:CLAUSE_CLASS[CL]←WITH_CLASS;
RETURN(CL);
END;
! onclause;
RECURSIVE RPTR(CLAUSE) PROCEDURE DURCMON(BOOLEAN ISCLAUSE(TRUE);INTEGER OFFSET(0));
BEGIN
RPTR(EXPR$)EXP,ACTION,CMBODY; RPTR(CLAUSE)CL;
WORD2_READ(">","≥");
EXP←$$GTANYEXP("DURATION CMON",#SC);
ACTION←ACTION$;
CMBODY←$DURCPCODE(EXP,ACTION);
IF ISCLAUSE THEN CL←MK_COND($CMONPCODE(CMBODY,#CMDRA),DURATION_COND)
ELSE CL←MK_COND($ONPCODE(CMBODY,OFFSET,#CMDRA),DURATION_COND);
CLAUSE:CMONCODE[CL]←#CMDRA;
RETURN(CL);
END;
RECURSIVE RPTR(CLAUSE) PROCEDURE EXPCMON(BOOLEAN ISCLAUSE(TRUE);INTEGER OFFSET(0));
BEGIN
RPTR(EXPR$)EXP,ACTION,CMBODY; RPTR(CLAUSE)CL;
STOKEN←TRUE;
EXP←$$GTANYEXP("EXPRESSION CMON",#SC);
ACTION←ACTION$;
CMBODY←$EXPCPCODE(EXP,ACTION);
IF ISCLAUSE THEN CL←MK_COND($CMONPCODE(CMBODY,#CMEXP),EXPRESSION_COND)
ELSE CL←MK_COND($ONPCODE(CMBODY,OFFSET,#CMEXP),EXPRESSION_COND);
CLAUSE:CMONCODE[CL]←#CMEXP;
RETURN(CL);
END;
RECURSIVE RPTR(CLAUSE) PROCEDURE EVCMON(BOOLEAN ISCLAUSE(TRUE);INTEGER OFFSET(0));
BEGIN
RPTR(EXPR$)EXP,ACTION,CMBODY; RPTR(SYMBOL)SYM; RPTR(CLAUSE)CL;
STOKEN←TRUE;
EXP←$$GTIDREF(#EV,SYM,"EVENT CMON");
ACTION←ACTION$;
CMBODY←$EVCPCODE(EXP,ACTION);
IF ISCLAUSE THEN CL←MK_COND($CMONPCODE(CMBODY,#CMEVT),EVENT_COND)
ELSE CL←MK_COND($ONPCODE(CMBODY,OFFSET,#CMEVT),EVENT_COND);
CLAUSE:CMONCODE[CL]←#CMEVT;
RETURN(CL);
END;
RECURSIVE RPTR(CLAUSE) PROCEDURE ONCLAUSE(RPTR(EXPR$)CFRAME);
BEGIN INTEGER NBITS; BOOLEAN SAVERRORCMON; RPTR(CLAUSE)CL;
$COMPILE←$COMPILE+1;
GTOKEN;
SAVERRORCMON←$ERRCMON; $ERRCMON←FALSE; $ERRLEVEL←$LEVEL;
IF EQU(TOKEN,"ERROR") THEN
BEGIN
$ERRCMON←TRUE;
CL←NEW_RECORD(CLAUSE);
CLAUSE:CLAUSE_CLASS[CL]←WITH_CLASS; ! actually a WITH ;
WORD_READ("=");
CLAUSE:FVALUE[CL]←$GTREAL("ERROR condition monitor");
CLAUSE:TYPE[CL]←FAILURE_COND;
CLAUSE:BODY[CL]←RPARSE("DO");
GTOKEN(FALSE);
END
ELSE
BEGIN
IF TOKEN="|" THEN
BEGIN GTOKEN;
IF EQU(TOKEN,"FORCE") THEN
CL←FORCECMON(CFRAME,FORCE_COND,TRUE)
ELSE IF EQU(TOKEN,"TORQUE") THEN
CL←FORCECMON(CFRAME,TORQUE_COND,TRUE)
ELSE ERROR("Must have FORCE or TORQUE after |");
END
ELSE IF EQU(TOKEN,"FORCE") THEN CL←FORCECMON(CFRAME,FORCE_COND)
ELSE IF EQU(TOKEN,"TORQUE") THEN CL←FORCECMON(CFRAME,TORQUE_COND)
ELSE IF EQU(TOKEN,"DURATION") THEN CL←DURCMON
ELSE IF (#TOKEN=ID_TYPE) AND (SYMBOL:TYPE[TOKENPTR]=#EV)
THEN CL←EVCMON
ELSE CL←EXPCMON;
CLAUSE:HEADER[CL]←$PCD11(XXCMENBL,$TMPOFF);
CLAUSE:KILDECL[CL]←$PCD11(XXCMDSBL,$TMPOFF);
CLAUSE:CLAUSE_CLASS[CL]←ON_CLASS;
$TMPOFF←$TMPOFF+1;
GTOKEN(FALSE);
END;
$ERRCMON←SAVERRORCMON; $ERRLEVEL←$LEVEL;
$COMPILE←$COMPILE-1;
RETURN(CL);
END;
! movepcode;
RPTR(EXPR$)PROCEDURE $APPRPCODE(RPTR(EXPR$)DEP,FRM);
BEGIN
RPTR(EXPR$) ARRAY A[1:4];
A[1]←DEP;
A[2]←EXPR$1(XMKDPRH);
A[3]←FRM;
A[4]←EXPR$1(XTTMUL);
RETURN($AAPPEND(A));
END;
RPTR(EXPR$)PROCEDURE $DEPRPCODE(RPTR(EXPR$)DEP,FRM);
BEGIN
RPTR(EXPR$) ARRAY A[1:5];
A[1]←DEP;
A[2]←EXPR$1(XMKDPRH);
A[3]←FRM;
A[4]←EXPR$1(XGVALS);
A[5]←EXPR$1(XTTMUL);
RETURN($AAPPEND(A));
END;
RECURSIVE RPTR(EXPR$)PROCEDURE MOVEPCODE(RPTR(EXPR$)CONTROLFRAME;
RPTR(RSTACK)VIALIST; RPTR(EXPR$)DEST; RPTR(RSTACK)WITHLIST,ONLIST,DECLIST;
INTEGER NEWVARS);
BEGIN
INTEGER GBITS,#SEGMENTS,ERRORBITS,FFRAMEBITS;
BOOLEAN DEPARTUREINCLUDED,APPROACHINCLUDED,FORCEINCLUDED,COMPLYINCLUDED;
RPTR(RSTACK)FINALEXPR,CMDSBLEXPR,CMENBLEXPR;
RPTR(RSTACK)HEADEREXPR;
RPTR(EXPR$)ARRAY M[0:6];
RPTR(EXPR$)WOBBLEEXPR,DURATIONEXPR,SPEEDFEXPR,ERROREXPR;
RPTR(EXPR$)DEPARTUREEXPR,APPROACHEXPR,STIFFNESSEXPR;
RPTR(EXPR$)FFRAMEEXPR,SETBASEXPR;
RPTR(CLAUSE)CL;
INTEGER I,J,JC;
M[0]←$RAPPEND(DECLIST); ! get the declarations out of the way ;
GBITS←NONULLING_GBITS; ! default global bits;
#SEGMENTS←1; ! for the destination ;
J←RSIZE(WITHLIST);
JC←RSIZE(ONLIST);
! take care of WITH list ;
HEADEREXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL J DO
IF CLAUSE:TYPE[CL←RSTACK:STACK[WITHLIST][I]]=NULLING_COND
THEN GBITS←GBITS LAND (LNOT(NONULLING_GBITS) LOR
CLAUSE:GBITS[CL])
ELSE IF CLAUSE:TYPE[CL]=DURATION_COND THEN
BEGIN DURATIONEXPR←CLAUSE:BODY[CL];
GBITS←GBITS LOR CLAUSE:GBITS[CL] END
ELSE IF CLAUSE:TYPE[CL]=SPEED_FACTOR_COND THEN
BEGIN SPEEDFEXPR←CLAUSE:BODY[CL];
GBITS←GBITS LOR CLAUSE:GBITS[CL] END
ELSE IF CLAUSE:TYPE[CL]=WOBBLE_COND THEN
BEGIN WOBBLEEXPR←CLAUSE:BODY[CL];
GBITS←GBITS LOR CLAUSE:GBITS[CL] END
ELSE IF CLAUSE:TYPE[CL]=APPROACH_COND THEN
BEGIN IF CLAUSE:BODY[CL] THEN
APPROACHEXPR←$APPRPCODE(CLAUSE:BODY[CL],DEST)
ELSE APPROACHEXPR←NULL_RECORD;
APPROACHINCLUDED←TRUE;
END
ELSE IF CLAUSE:TYPE[CL]=DEPARTURE_COND THEN
BEGIN IF CLAUSE:BODY[CL] THEN
DEPARTUREEXPR←$DEPRPCODE(CLAUSE:BODY[CL],CONTROLFRAME)
ELSE DEPARTUREEXPR←NULL_RECORD;
DEPARTUREINCLUDED←TRUE;
END
ELSE IF CLAUSE:TYPE[CL]=SETBASE_COND THEN
SETBASEXPR←CLAUSE:BODY[CL]
ELSE IF CLAUSE:TYPE[CL]=FORCE_COND OR CLAUSE:TYPE[CL]=TORQUE_COND
THEN BEGIN RPUSH(HEADEREXPR,CLAUSE:BODY[CL]);
IF CLAUSE:FFRAME[CL] THEN FFRAMEEXPR←CLAUSE:FFRAME[CL];
FFRAMEBITS←CLAUSE:FVALUE[CL];
COMPLYINCLUDED←TRUE;
FORCEINCLUDED←TRUE;
END
ELSE IF CLAUSE:TYPE[CL]=STIFFNESS_COND THEN
STIFFNESSEXPR←CLAUSE:BODY[CL];
FINALEXPR←NEW_RSTACK;
CMENBLEXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL JC DO
IF CLAUSE:TYPE[CL←RSTACK:STACK[ONLIST][I]]=FAILURE_COND THEN
BEGIN ERROREXPR←CLAUSE:BODY[CL];
ERRORBITS←CLAUSE:FVALUE[CL];
END
ELSE
BEGIN ! on clause ;
RPUSH(CMENBLEXPR,CLAUSE:HEADER[CL]);
IF CLAUSE:TYPE[CL]=FORCE_COND OR CLAUSE:TYPE[CL]=TORQUE_COND
OR CLAUSE:TYPE[CL]=FORCE_FRAME_COND THEN
BEGIN
FFRAMEEXPR←CLAUSE:FFRAME[CL];
FFRAMEBITS←CLAUSE:FVALUE[CL];
FORCEINCLUDED←TRUE;
END;
END;
IF FORCEINCLUDED
THEN IF FFRAMEEXPR THEN RPUSH(FINALEXPR,FFRAMEEXPR)
ELSE RPUSH(FINALEXPR,$FFPCODE(CONTROLFRAME,FFRAMEBITS));
IF SETBASEXPR THEN RPUSH(FINALEXPR,SETBASEXPR)
ELSE IF COMPLYINCLUDED THEN RPUSH(FINALEXPR,EXPR$1(XSETBAS));
IF STIFFNESSEXPR THEN RPUSH(FINALEXPR,STIFFNESSEXPR)
ELSE IF COMPLYINCLUDED THEN RPUSH(FINALEXPR,EXPR$1(XSTIF0));
IF RSIZE(HEADEREXPR) THEN RPUSH(FINALEXPR,$RAPPEND(HEADEREXPR));
IF RSIZE(CMENBLEXPR) THEN RPUSH(FINALEXPR,$RAPPEND(CMENBLEXPR));
IF DURATIONEXPR THEN RPUSH(FINALEXPR,DURATIONEXPR);
IF SPEEDFEXPR THEN RPUSH(FINALEXPR,SPEEDFEXPR);
IF WOBBLEEXPR THEN RPUSH(FINALEXPR,WOBBLEEXPR);
RPUSH(FINALEXPR,DEST);
IF APPROACHEXPR THEN RPUSH(FINALEXPR,APPROACHEXPR);
#SEGMENTS←#SEGMENTS+1;
J←RSIZE(VIALIST);
FOR I←J STEP -1 UNTIL 1 DO
BEGIN
RPTR(CLAUSE)C;
C←RSTACK:STACK[VIALIST][I];
IF CLAUSE:VELOCITY[C] THEN
RPUSH(FINALEXPR,CLAUSE:BODY[CLAUSE:VELOCITY[C]]);
IF CLAUSE:DURATION[C] THEN
RPUSH(FINALEXPR,CLAUSE:BODY[CLAUSE:DURATION[C]]);
RPUSH(FINALEXPR,CLAUSE:BODY[C]);
END;
#SEGMENTS←#SEGMENTS+J;
IF DEPARTUREEXPR THEN
BEGIN #SEGMENTS←#SEGMENTS+1;
RPUSH(FINALEXPR,DEPARTUREEXPR);
END
ELSE IF NOT DEPARTUREINCLUDED THEN #SEGMENTS←#SEGMENTS+1;
RPUSH(FINALEXPR,CONTROLFRAME);
M[1]←$RAPPEND(FINALEXPR);
IPUSH(XPMOVE); IPUSH(#SEGMENTS);
IF DEPARTUREEXPR THEN
BEGIN IPUSH(DEPRPT_GBITS); IPUSH(-1); END
ELSE IF DEPARTUREINCLUDED THEN IPUSH(NODEPR_GBITS+DEPRPT_GBITS);
FOR I←1 STEP 1 UNTIL J DO
BEGIN
RPTR(CLAUSE)C;
C←RSTACK:STACK[VIALIST][I];
IPUSH(CLAUSE:GBITS[C]);
IPUSH(-1); ! position ;
IF CLAUSE:DURATION[C] THEN IPUSH(-1);
IF CLAUSE:VELOCITY[C] THEN IPUSH(-1);
END;
IF APPROACHEXPR THEN
BEGIN IPUSH(APPRPT_GBITS); IPUSH(-1); END;
IPUSH(DESTPT_GBITS); IPUSH(-1);
IPUSH(GBITS); ! Global control bits;
IF WOBBLEEXPR THEN IPUSH(-1);
IF SPEEDFEXPR THEN IPUSH(-1);
IF DURATIONEXPR THEN IPUSH(-1);
IPUSH(ERRORBITS); ! ERROR BITS ZERO FOR NOW;
IPUSH(0); ! NEXT PCODE ADDRESS;
IPUSH(0); ! RETRY ADDRESS;
M[2]←βEXPR$; ! BODY;
M[3]←ERROREXPR; ! ERROR HANDLER;
CMDSBLEXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL JC
DO RPUSH(CMDSBLEXPR,CLAUSE:KILDECL[RSTACK:STACK[ONLIST][I]]);
M[4]←$RAPPEND(CMDSBLEXPR); ! actually disable all cmons;
M[5]←EXPR$1(XUPDEPR); ! tail end;
M[6]←$PCD11(XXPKVAR,NEWVARS);
J←EXPR$:#BODY[M[2]];
EXPR$:BODY[M[2]][J]←-EXPR$OFF(M,1,2)+2;
EXPR$:BODY[M[2]][J-1]←EXPR$OFF(M,3,3)+1;
RETURN($AAPPEND(M));
END;
! moveproc;
RECURSIVE RPTR(EXPR$) PROCEDURE COMMON_MOVEPROC(RPTR(EXPR$)MFR);
BEGIN
RPTR(EXPR$)DEST,TEMP; ! destination expression ;
RPTR(RSTACK)VIALIST,ONLIST,WITHLIST,DECLIST;
INTEGER NEWVARS; ! new variables created;
NEWVARS←0; ! initially zero;
GTOKEN;
VIALIST←NEW_RSTACK; ! initialize via list;
ONLIST←NEW_RSTACK; ! initialize on list;
WITHLIST←NEW_RSTACK;! initialize with list;
DECLIST←NEW_RSTACK; ! initialize declaration list ;
WHILE EQU(TOKEN,"TO") OR EQU(TOKEN,"VIA") OR EQU(TOKEN,"WITH")
OR EQU(TOKEN,"ON") OR EQU(TOKEN,"BY") DO
BEGIN
RPTR(CLAUSE)V,O,W;
IF EQU(TOKEN,"TO") THEN
BEGIN DEST←$$GTANYEXP("Destination part of MOVE",#FR);
GTOKEN(FALSE); END
ELSE IF EQU(TOKEN,"BY") THEN
BEGIN RPTR(EXPR$)ARRAY C[1:4];
C[1]←MFR;
C[2]←EXPR$1(XGVALS);
C[3]←$$GTANYEXP("Destination part of MOVE BY",#VT);
c[4]←expr$1(XTVADD);
DEST←$AAPPEND(C); GTOKEN(FALSE);
END
ELSE IF EQU(TOKEN,"VIA") THEN
DO BEGIN V←VIACLAUSE; RPUSH(VIALIST,V); GTOKEN(FALSE); END
UNTIL TOKEN≠","
ELSE IF EQU(TOKEN,"ON")
THEN BEGIN O←ONCLAUSE(MFR); RPUSH(ONLIST,O);
IF CLAUSE:DECL[O] THEN RPUSH(DECLIST,CLAUSE:DECL[O]);
IF CLAUSE:TYPE[O]≠FAILURE_COND THEN NEWVARS←NEWVARS+1;
END
ELSE IF EQU(TOKEN,"WITH")
THEN BEGIN W←WITHCLAUSE(MOVE_ST,MFR); RPUSH(WITHLIST,W);
GTOKEN(FALSE); END;
END;
STOKEN←TRUE;
TEMP←MOVEPCODE(MFR,VIALIST,DEST,WITHLIST,ONLIST,DECLIST,NEWVARS);
RETURN(TEMP);
END;
RECURSIVE INTERNAL PROCEDURE MOVEPROC;
BEGIN
RPTR(EXPR$)MFR; RPTR(SYMBOL)FR1;
MFR←$$GTIDREF(#FR,FR1,"to follow MOVE command");
OLDSAV("MOVE",SYMBOL:PNAME[FR1],MFR);
$$PCODE←COMMON_MOVEPROC(MFR);
OLDSAV("MOVE",SYMBOL:PNAME[FR1],MFR);
END;
PRELOAD_WITH XPUSHINTI,0,XPUSHINTI,0,XPUSHINTI,1,XPUSHINTI,0,XPUSHINTI,0;
INTEGER ARRAY ARRDIR[-6:3];
INTERNAL PROCEDURE DELMOVEPROC(INTEGER DIR);
BEGIN
RPTR(EXPR$)MFR,DEST; RPTR(SYMBOL)FR1; INTEGER I,NEWVARS;
RPTR(EXPR$)ARRAY C[1:4];
RPTR(RSTACK)VIALIST,WITHLIST,ONLIST,DECLIST;
VIALIST←NEW_RSTACK;
WITHLIST←NEW_RSTACK;
ONLIST←NEW_RSTACK;
DECLIST←NEW_RSTACK;
MFR←$$GTIDREF(#FR,FR1,"to follow incremental MOVE command");
WORD_READ("BY");
C[1]←MFR;
C[2]←EXPR$1(XGVALS);
C[3]←$$GTANYEXP("Destination part of MOVE BY",#SC);
FOR I←-DIR*2 STEP 1 UNTIL 5-DIR*2 DO IPUSH(ARRDIR[I]);
IPUSH(XVMAKE); IPUSH(XSVMUL);IPUSH(XTVADD);
C[4]←βEXPR$;
DEST←$AAPPEND(C); GTOKEN(FALSE);
STOKEN←TRUE;
$$PCODE←MOVEPCODE(MFR,VIALIST,DEST,WITHLIST,ONLIST,DECLIST,NEWVARS);
END;
! centerpcode;
RECURSIVE RPTR(EXPR$)PROCEDURE CENTERPCODE(INTEGER MECH_BITS;RPTR(RSTACK)ONLIST);
BEGIN INTEGER ERRORBITS; RPTR(RSTACK)HEADEREXPR;
RPTR(EXPR$)ARRAY M[1:3]; RPTR(CLAUSE)CL;
RPTR(EXPR$)ERROREXPR;
INTEGER I,J,JC;
JC←RSIZE(ONLIST);
FOR I←1 STEP 1 UNTIL JC DO
IF CLAUSE:TYPE[CL←RSTACK:STACK[ONLIST][I]]=FAILURE_COND THEN
BEGIN ERROREXPR←CLAUSE:BODY[CL];
ERRORBITS←CLAUSE:FVALUE[CL];
END
ELSE ERROR("ONLY ERROR CMON ALLOWED FOR CENTER COMMAND");
M[1]←EXPR$1(XNOOP);
IPUSH(XCENTER); IPUSH(MECH_BITS);
IPUSH(ERRORBITS); ! ERROR BITS ;
IPUSH(0); ! NEXT PCODE ;
IPUSH(0); ! RETRY ADDRESS ;
M[2]←βEXPR$; ! BODY;
M[3]←ERROREXPR; ! ERROR HANDLER;
J←EXPR$:#BODY[M[2]];
EXPR$:BODY[M[2]][J]←-EXPR$OFF(M,2,2)+2;
EXPR$:BODY[M[2]][J-1]←EXPR$OFF(M,3,3)+1;
RETURN($AAPPEND(M));
END;
! centerproc;
RECURSIVE INTERNAL PROCEDURE CENTERPROC;
BEGIN
RPTR(RSTACK)ONLIST; STRING POS; INTEGER TMPOFF0; INTEGER BITS;
POS←ARM_READ; ! if the arm is not indicated BARM is assumed;
IF EQU(POS,"BARM") THEN BITS←BARM_MECH+BHAND_MECH ELSE PRINT(#NOTYET);
OLDSAV("CENTER",POS,NULL_RECORD);
TMPOFF0←$TMPOFF;
GTOKEN(FALSE);
ONLIST←NEW_RSTACK; ! initialize on list;
WHILE EQU(TOKEN,"ON")
DO BEGIN RPTR(CLAUSE) O;
O←ONCLAUSE(NULL_RECORD); RPUSH(ONLIST,O);
IF CLAUSE:TYPE[O]≠FAILURE_COND THEN ERROR("Only ERROR cmon allowed for CENTER");
END;
STOKEN←TRUE;
$TMPOFF←TMPOFF0;
$$PCODE←CENTERPCODE(BITS,ONLIST);
END;
! handpcode;
RECURSIVE RPTR(EXPR$)PROCEDURE HANDPCODE(RPTR(EXPR$)HANDID,HANDEXPR;
RPTR(RSTACK)WITHLIST,ONLIST,DECLIST; INTEGER NEWVARS);
BEGIN
INTEGER GBITS,#SEGMENTS,ERRORBITS;
RPTR(RSTACK)FINALEXPR,CMDSBLEXPR,CMENBLEXPR;
RPTR(RSTACK)HEADEREXPR;
RPTR(EXPR$)ARRAY M[0:6];
RPTR(EXPR$)DURATIONEXPR,SPEEDFEXPR,ERROREXPR;
RPTR(CLAUSE)CL;
INTEGER I,J,JC;
M[0]←$RAPPEND(DECLIST); ! get the declarations out of the way ;
GBITS←NONULLING_GBITS; ! default global bits;
#SEGMENTS←2; ! for the destination ;
J←RSIZE(WITHLIST);
JC←RSIZE(ONLIST);
! take care of WITH list ;
HEADEREXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL J DO
IF CLAUSE:TYPE[CL←RSTACK:STACK[WITHLIST][I]]=NULLING_COND
THEN GBITS←GBITS LAND (LNOT(NONULLING_GBITS) LOR
CLAUSE:GBITS[CL])
ELSE IF CLAUSE:TYPE[CL]=DURATION_COND THEN
BEGIN DURATIONEXPR←CLAUSE:BODY[CL];
GBITS←GBITS LOR CLAUSE:GBITS[CL] END
ELSE IF CLAUSE:TYPE[CL]=SPEED_FACTOR_COND THEN
BEGIN SPEEDFEXPR←CLAUSE:BODY[CL];
GBITS←GBITS LOR CLAUSE:GBITS[CL] END;
FINALEXPR←NEW_RSTACK;
CMENBLEXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL JC DO
IF CLAUSE:TYPE[CL←RSTACK:STACK[ONLIST][I]]=FAILURE_COND THEN
BEGIN ERROREXPR←CLAUSE:BODY[CL];
ERRORBITS←CLAUSE:FVALUE[CL];
END
ELSE RPUSH(CMENBLEXPR,CLAUSE:HEADER[CL]);
IF RSIZE(HEADEREXPR) THEN RPUSH(FINALEXPR,$RAPPEND(HEADEREXPR));
IF RSIZE(CMENBLEXPR) THEN RPUSH(FINALEXPR,$RAPPEND(CMENBLEXPR));
IF DURATIONEXPR THEN RPUSH(FINALEXPR,DURATIONEXPR);
IF SPEEDFEXPR THEN RPUSH(FINALEXPR,SPEEDFEXPR);
RPUSH(FINALEXPR,HANDEXPR);
RPUSH(FINALEXPR,HANDID);
M[1]←$RAPPEND(FINALEXPR);
IPUSH(XPMOVE); IPUSH(#SEGMENTS);
IPUSH(NODEPR_GBITS+DEPRPT_GBITS); ! will be ignored anyway ;
IPUSH(-1); ! destination value is on stack ;
IPUSH(GBITS); ! Global control bits;
IF SPEEDFEXPR THEN IPUSH(-1);
IF DURATIONEXPR THEN IPUSH(-1);
IPUSH(ERRORBITS); ! ERROR BITS ZERO FOR NOW;
IPUSH(0); ! NEXT PCODE ADDRESS;
IPUSH(0); ! RETRY ADDRESS;
M[2]←βEXPR$; ! BODY;
M[3]←ERROREXPR; ! ERROR HANDLER;
CMDSBLEXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL JC
DO RPUSH(CMDSBLEXPR,CLAUSE:KILDECL[RSTACK:STACK[ONLIST][I]]);
M[4]←$RAPPEND(CMDSBLEXPR); ! actually disable all cmons;
M[5]←EXPR$1(XUPDEPR); ! tail end;
M[6]←$PCD11(XXPKVAR,NEWVARS);
J←EXPR$:#BODY[M[2]];
EXPR$:BODY[M[2]][J]←-EXPR$OFF(M,1,2)+2;
EXPR$:BODY[M[2]][J-1]←EXPR$OFF(M,3,3)+1;
RETURN($AAPPEND(M));
END;
! handproc,openproc;
RECURSIVE RPTR(EXPR$) PROCEDURE HANDPROC(RPTR(EXPR$)HANDID,HANDEXPR);
BEGIN
RPTR(RSTACK)ONLIST,WITHLIST,DECLIST;
INTEGER NEWVARS; ! new variables created;
NEWVARS←0; ! initially zero;
ONLIST←NEW_RSTACK; ! initialize on list;
WITHLIST←NEW_RSTACK;! initialize with list;
DECLIST←NEW_RSTACK; ! initialize declaration list ;
GTOKEN(FALSE);
WHILE EQU(TOKEN,"WITH") OR EQU(TOKEN,"ON") DO
BEGIN RPTR(CLAUSE)O,W;
IF EQU(TOKEN,"ON")
THEN BEGIN O←ONCLAUSE(HANDID); RPUSH(ONLIST,O);
IF CLAUSE:DECL[O] THEN RPUSH(DECLIST,CLAUSE:DECL[O]);
IF CLAUSE:TYPE[O]≠FAILURE_COND THEN NEWVARS←NEWVARS+1;
END
ELSE IF EQU(TOKEN,"WITH")
THEN BEGIN W←WITHCLAUSE(OPEN_ST,HANDID); RPUSH(WITHLIST,W);
GTOKEN(FALSE); END;
END;
STOKEN←TRUE;
RETURN(HANDPCODE(HANDID,HANDEXPR,WITHLIST,ONLIST,DECLIST,NEWVARS));
END;
RECURSIVE RPTR(EXPR$) PROCEDURE COMMON_OPENPROC(RPTR(EXPR$)HANDID;
BOOLEAN DISCRIMINATOR(TRUE));
BEGIN RPTR(EXPR$)TEMP,HANDEXPR;
WORD2_READ("TO","BY");
IF EQU(TOKEN,"TO") THEN HANDEXPR←$$GTANYEXP("OPEN or CLOSE statement",#SC)
ELSE BEGIN RPTR(EXPR$) ARRAY C[1:4];
C[1]←HANDID;
C[2]←EXPR$1(XGVALS);
C[3]←$$GTANYEXP("OPEN or CLOSE statement",#SC);
C[4]←EXPR$1(IF DISCRIMINATOR THEN XSADD ELSE XSSUB);
HANDEXPR←$AAPPEND(C);
END;
STOKEN←TRUE;
TEMP←HANDPROC(HANDID,HANDEXPR);
RETURN(TEMP);
END;
INTERNAL RECURSIVE PROCEDURE OPENPROC(BOOLEAN DISCRIMINATOR(TRUE));
BEGIN
STRING HAND,ACTUAL; RPTR(EXPR$)HANDID; RPTR(SYMBOL)S1;
IF DISCRIMINATOR THEN ACTUAL←"OPEN " ELSE ACTUAL←"CLOSE ";
GTOKEN;
IF EQU(HAND←TOKEN,"BHAND") OR EQU(HAND,"YHAND")
THEN BEGIN STOKEN←TRUE; HANDID←$$GTIDREF(#SC,S1,ACTUAL); END
ELSE ERROR("Need BHAND or YHAND after "&ACTUAL);
OLDSAV(ACTUAL,HAND,HANDID);
$$PCODE←COMMON_OPENPROC(HANDID);
OLDSAV(ACTUAL,HAND,HANDID);
END;
! toproc,byproc;
INTERNAL RECURSIVE PROCEDURE TOPROC;
BEGIN
RPTR(EXPR$)MFR; STRING CMD,OBJ;
GETOLD(CMD,OBJ,MFR);
IF EQU(CMD,"MOVE") THEN $$PCODE←COMMON_MOVEPROC(MFR)
ELSE IF EQU(CMD,"OPEN ") THEN $$PCODE←COMMON_OPENPROC(MFR,TRUE)
ELSE IF EQU(CMD,"CLOSE ") THEN $$PCODE←COMMON_OPENPROC(MFR,FALSE);
OLDSAV(CMD,OBJ,MFR);
END;
INTERNAL RECURSIVE PROCEDURE BYPROC;
BEGIN
RPTR(EXPR$)MFR; STRING CMD,OBJ;
GETOLD(CMD,OBJ,MFR);
IF EQU(CMD,"MOVE") THEN $$PCODE←COMMON_MOVEPROC(MFR)
ELSE IF EQU(CMD,"OPEN ") THEN $$PCODE←COMMON_OPENPROC(MFR,TRUE)
ELSE IF EQU(CMD,"CLOSE ") THEN $$PCODE←COMMON_OPENPROC(MFR,FALSE);
OLDSAV(CMD,OBJ,MFR);
END;
! stoppcode;
RPTR(EXPR$)PROCEDURE STOPPCODE(RPTR(EXPR$)C);
RETURN($APPEND(C,EXPR$1(XPSTOP)));
! stopproc;
INTERNAL PROCEDURE STOPPROC;
BEGIN RPTR(EXPR$) C; RPTR(SYMBOL)SYM;
GTOKEN(FALSE);
IF #TOKEN=ID_TYPE THEN
BEGIN STOKEN←TRUE; C←$$GTIDREF(#FR,SYM,"STOP command"); END
ELSE C←OLDCFRAME;
$$PCODE←STOPPCODE(C);
END;
! operproc;
RPTR(EXPR$)RECURSIVE PROCEDURE OPERPCODE(RPTR(RSTACK)ONLIST,WITHLIST,DECLIST;
INTEGER #VARS);
BEGIN
INTEGER I,ERRORBITS,J;
BOOLEAN CCW;
RPTR(CLAUSE)C;
RPTR(EXPR$)TORQ_EXP,VEL_EXP,DUR_EXP,OPERCODE,ERROREXPR;
RPTR(RSTACK)HEADEREXPR,FINALEXPR,CMENBLEXPR,CMDSBLEXPR;
RPTR(EXPR$)ARRAY OP[0:6];
HEADEREXPR←NEW_RSTACK;
FINALEXPR←NEW_RSTACK;
CMENBLEXPR←NEW_RSTACK;
CCW←FALSE; ! default=clockwise;
DUR_EXP←$PCD11(XXPUSHINTI,2); ! default duration=2 seconds ;
VEL_EXP←$PCD11(XXPUSHINTI,0); ! default velocity=0;
TORQ_EXP←$PCD11(XXPUSHINTI,0); ! default torque=0;
OP[0]←$RAPPEND(DECLIST);
FOR I←1 STEP 1 UNTIL RSIZE(WITHLIST) DO
CASE CLAUSE:TYPE[C←RSTACK:STACK[WITHLIST][I]] OF
BEGIN
[CLOCKWISE_COND]
CCW←FALSE;
[CCLOCKWISE_COND]
CCW←TRUE;
[ANGULAR_VELOCITY_COND]
VEL_EXP←CLAUSE:BODY[C];
[DRIVER_TORQUE_COND]
TORQ_EXP←CLAUSE:BODY[C];
[DURATION_COND]
DUR_EXP←CLAUSE:BODY[C];
ELSE ERROR("Unexpected clause found , clause no. "&cvs(I))
END;
FOR I←1 STEP 1 UNTIL RSIZE(ONLIST) DO
CASE CLAUSE:TYPE[C←RSTACK:STACK[ONLIST][I]] OF
BEGIN
[FAILURE_COND]
BEGIN
ERRORBITS←CLAUSE:FVALUE[C];
ERROREXPR←CLAUSE:BODY[C];
END;
[DURATION_COND][EXPRESSION_COND][EVENT_COND]
RPUSH(CMENBLEXPR,CLAUSE:HEADER[C]);
ELSE ERROR("Invalid clause for operate")
END;
RPUSH(FINALEXPR,VEL_EXP);
IF CCW THEN RPUSH(FINALEXPR,$PCD1(XXSNEG));
RPUSH(FINALEXPR,TORQ_EXP);
IF CCW THEN RPUSH(FINALEXPR,$PCD1(XXSNEG));
RPUSH(FINALEXPR,DUR_EXP);
OP[1]←$RAPPEND(FINALEXPR);
IPUSH(XOPERATE);
IPUSH(DRIVERSB);
IPUSH(0); ! compliance bits;
IPUSH(DRIVER_MECH); ! driver mechanism bits;
IPUSH(ERRORBITS); ! error bits;
IPUSH(0); ! next address;
IPUSH(0); ! retry address;
OP[2]←βEXPR$;
OP[3]←ERROREXPR;
CMDSBLEXPR←NEW_RSTACK;
FOR I←1 STEP 1 UNTIL RSIZE(ONLIST)
DO RPUSH(CMDSBLEXPR,CLAUSE:KILDECL[RSTACK:STACK[ONLIST][I]]);
OP[4]←$RAPPEND(CMDSBLEXPR); ! actually disable all cmons;
OP[5]←EXPR$1(XUPDEPR); ! tail end;
OP[6]←$PCD11(XXPKVAR,#VARS);
J←EXPR$:#BODY[OP[2]];
EXPR$:BODY[OP[2]][J]←-EXPR$OFF(OP,1,2)+2;
EXPR$:BODY[OP[2]][J-1]←EXPR$OFF(OP,3,3)+1;
RETURN($AAPPEND(OP));
END;
INTERNAL RECURSIVE PROCEDURE OPERPROC;
BEGIN
RPTR(RSTACK)ONLIST,WITHLIST,DECLIST;
RPTR(CLAUSE)C; INTEGER NEWVARS;
NEWVARS←0;
ONLIST←NEW_RSTACK;
WITHLIST←NEW_RSTACK;
DECLIST←NEW_RSTACK;
WORD2_READ("DRIVER","VISE");
IF EQU(TOKEN,"VISE") THEN ERROR("VISE not operable yet");
GTOKEN;
WHILE EQU(TOKEN,"CLOCKWISE") OR EQU(TOKEN,"COUNTER_CLOCKWISE") OR
EQU(TOKEN,"WITH") OR EQU(TOKEN,"ON") DO
BEGIN
IF EQU(TOKEN,"CLOCKWISE") OR EQU(TOKEN,"COUNTER_CLOCKWISE") THEN
BEGIN
STOKEN←TRUE; C←WITHCLAUSE(OPERATE_ST,NULL_RECORD); RPUSH(WITHLIST,C);
END
ELSE IF EQU(TOKEN,"WITH")
THEN BEGIN C←WITHCLAUSE(OPERATE_ST,NULL_RECORD); RPUSH(WITHLIST,C); GTOKEN(FALSE); END
ELSE BEGIN C←ONCLAUSE(NULL_RECORD); RPUSH(ONLIST,C);
IF CLAUSE:DECL[C] THEN RPUSH(DECLIST,CLAUSE:DECL[C]);
IF CLAUSE:TYPE[C]≠FAILURE_COND THEN NEWVARS←NEWVARS+1;
END;
END;
$$PCODE←OPERPCODE(ONLIST,WITHLIST,DECLIST,NEWVARS);
END;
! driveproc;
INTERNAL PROCEDURE DRIVEPROC;
BEGIN INTEGER ARM,JOINT; BOOLEAN ISABS; RPTR(EXPR$)ARRAY D[1:2];
RPTR(EXPR$)SCEXPR;
WORD2_READ("BJT","YJT");
IF EQU(TOKEN,"BJT") THEN ARM←BLUE ELSE ARM←YELLOW;
WORD_READ("(");
JOINT←INT_READ;
IF JOINT<1 OR JOINT>7 THEN ERROR("Joint values must be between 1 and 7 for drive");
WORD_READ(")");
WORD2_READ("TO","BY");
IF EQU(TOKEN,"TO") THEN ISABS←TRUE ELSE ISABS←FALSE;
D[1]←$$GTANYEXP("DRIVE COMMAND",#SC);
IF ISABS THEN IPUSH(XPDRIVE) ELSE IPUSH(XPBDRIVE);
IPUSH(ARM); IPUSH(JOINT);
IPUSH(0); ! ERROR ;
IPUSH(2); ! NEXT PCODE;
IPUSH(0); ! RETRY ;
D[2]←βEXPR$;
EXPR$:BODY[D[2]][EXPR$:#BODY[D[2]]]←-EXPR$OFF(D,1,2)+2;
$$PCODE←$AAPPEND(D);
END;
! onproc;
INTERNAL RECURSIVE PROCEDURE ONPROC(RPTR(SYMBOL)S(NULL_RECORD); BOOLEAN DEFER(FALSE));
BEGIN
INTEGER NBITS;RPTR(CLAUSE)CL; RPTR(RSTACK)R; RPTR(EXPR$)CFRAME;
INTEGER OFFSET;
$COMPILE←$COMPILE+1;
IF S=NULL_RECORD THEN ERROR("Can only handle labelled cmon now");
OFFSET←SYMBOL:OFFSET[S];
CFRAME←OLDCFRAME;
GTOKEN;
IF EQU(TOKEN,"ERROR") THEN ERROR("ERROR CMON only valid in move statement")
ELSE
BEGIN
IF TOKEN="|" THEN
BEGIN GTOKEN;
IF EQU(TOKEN,"FORCE") THEN
CL←FORCECMON(CFRAME,FORCE_COND,TRUE,FALSE,OFFSET)
ELSE IF EQU(TOKEN,"TORQUE") THEN
CL←FORCECMON(CFRAME,TORQUE_COND,TRUE,FALSE,OFFSET)
ELSE ERROR("Must have FORCE or TORQUE after |");
END
ELSE IF EQU(TOKEN,"FORCE") THEN CL←FORCECMON(CFRAME,FORCE_COND,FALSE,FALSE,OFFSET)
ELSE IF EQU(TOKEN,"TORQUE") THEN CL←FORCECMON(CFRAME,TORQUE_COND,FALSE,FALSE,OFFSET)
ELSE IF EQU(TOKEN,"DURATION") THEN CL←DURCMON(FALSE,OFFSET)
ELSE IF (#TOKEN=ID_TYPE) AND (SYMBOL:TYPE[TOKENPTR]=#EV)
THEN CL←EVCMON(FALSE,OFFSET)
ELSE CL←EXPCMON(FALSE,OFFSET);
R←NEW_RSTACK;
RPUSH(R,CLAUSE:DECL[CL]);
IF NOT DEFER THEN RPUSH(R,$PCD11(XXCMENBL,SYMBOL:OFFSET[S]));
$$PCODE←$RAPPEND(R);
GTOKEN(FALSE);
END;
$COMPILE←$COMPILE-1;
END;
END "PPROC2";